
(import
  (scheme base)
  (scheme read)
  (scheme write)
  (scheme inexact)
  (scheme process-context)
  (only (gauche base) exit-handler)
  (gauche threads)
  (srfi 18)
  (srfi 180)
  (rfc http)
  (tk))

(define pi 3.141592653589793)

(define-record-type <turtle-action>
  (turtle-action type pen-down? shown? x y x1 y1 x2 y2 color width facing)
  turtle-action?
  (type turtle-action-type)
  (pen-down? turtle-action-pen-down?)
  (shown? turtle-action-shown?)
  (x turtle-action-x)
  (y turtle-action-y)
  (x1 turtle-action-x1)
  (y1 turtle-action-y1)
  (x2 turtle-action-x2)
  (y2 turtle-action-y2)
  (color turtle-action-color)
  (width turtle-action-width)
  (facing turtle-action-facing))

(define (json-object->turtle-action json-object)
  (define (safe-assq-ref l key)
    (define result (assq key l))
    (and result (cdr result)))
  (define keys '(type penDown shown x y x1 y1 x2 y2 color width facing))
  (apply turtle-action
         (map (lambda (key) (safe-assq-ref json-object key))
              keys)))

(define scale-x 1.0)
(define scale-y 1.0)
(define displace-x 250)
(define displace-y 250)
(define bg-color #f)
(define line-color #f)
(define line-width #f)
(define page-id #f)

(define (draw-line! line-action)
  (define x1 (+ displace-x (* (turtle-action-x1 line-action) scale-x)))
  (define y1 (- displace-y (* (turtle-action-y1 line-action) scale-y)))
  (define x2 (+ displace-x (* (turtle-action-x2 line-action) scale-x)))
  (define y2 (- displace-y (* (turtle-action-y2 line-action) scale-y)))

  (tk-call '.canvas
           'create
           'line
           x1
           y1
           x2
           y2
           '-fill
           line-color
           '-width
           line-width))

(define (redraw-turtle! line-action)
  (define x (+ displace-x (* (turtle-action-x line-action) scale-x)))
  (define y (- displace-y (* (turtle-action-y line-action) scale-y)))
  (define theta-deg (turtle-action-facing line-action))
  (define theta (- (* theta-deg (/ 3.141592653589792 180))))
  (define turtle-size 24)
  (define (draw-circle x y size tags)
    (tk-call '.canvas
             'create
             'oval
             (- x (/ size 2.0))
             (- y (/ size 2.0))
             (+ x (/ size 2.0))
             (+ y (/ size 2.0))
             '-tags
             tags
             '-fill
             line-color))
                                        ; Delete any previous turtles
  (tk-call '.canvas 'delete 'turtle)
                                        ; Create the body
  (draw-circle x y turtle-size "turtle")
                                        ; Create the head
  (draw-circle (+ x (* 0.75 turtle-size (cos theta)))
               (+ y (* 0.75 turtle-size (sin theta)))
               (/ turtle-size 2)
               "turtle")
                                        ; Create the front legs
  (draw-circle (+ x (* 0.625 turtle-size (cos (+ theta 0.785))))
               (+ y (* 0.625 turtle-size (sin (+ theta 0.785))))
               (/ turtle-size 4)
               "turtle")
  (draw-circle (+ x (* 0.625 turtle-size (cos (- theta 0.785))))
               (+ y (* 0.625 turtle-size (sin (- theta 0.785))))
               (/ turtle-size 4)
               "turtle")
                                        ; Create the rear legs
  (draw-circle (+ x (* 0.625 turtle-size (cos (+ theta 2.356))))
               (+ y (* 0.625 turtle-size (sin (+ theta 2.356))))
               (/ turtle-size 4)
               "turtle")
  (draw-circle (+ x (* 0.625 turtle-size (cos (- theta 2.356))))
               (+ y (* 0.625 turtle-size (sin (- theta 2.356))))
               (/ turtle-size 4)
               "turtle"))

(define (clear-all!)
  (tk-call '.canvas 'delete "all"))

(define (draw-turtle-line! line-action)
  (define x1 (* (turtle-action-x1 line-action)))
  (define y1 (* (turtle-action-y1 line-action)))
  (define x2 (* (turtle-action-x2 line-action)))
  (define y2 (* (turtle-action-y2 line-action)))

  (define dy (- y2 y1))
  (define dx (- x2 x1))

  (define facing-amount-base (/ (* 180 (atan (/ dy dx))) pi))

  (define facing-amount (if (> x1 x2)
                            (+ facing-amount-base 180)
                            (+ facing-amount-base 360)))

  (cond
   ((turtle-action-shown? line-action)
    (draw-line! line-action)
    (redraw-turtle! (json-object->turtle-action `((x . ,(turtle-action-x2 line-action))
                                                  (y . ,(turtle-action-y2 line-action))
                                                  (facing . ,facing-amount)))))
   (else
    (draw-line! line-action))))

(define (delete-turtle!)
  #f)

(define (set-bg-color! instruction)
  (define color (turtle-action-color instruction))
  (tk-call '.canvas
           'configure
           '-bg
           color)
  (set! bg-color color))

(define (set-line-color! instruction)
  (set! line-color (turtle-action-color instruction)))

(define (set-line-width! instruction)
  (set! line-width (turtle-action-width instruction)))

(define (turtle-do! instruction)
  (case (string->symbol (turtle-action-type instruction))
    ((line)
     (draw-line! instruction))
    ((turtleLine)
     (draw-turtle-line! instruction))
    ((rotate)
     (redraw-turtle! instruction))
    ((clear)
     (clear-all!))
    ((bgColor)
     (set-bg-color! instruction))
    ((lineColor)
     (set-line-color! instruction))
    ((lineWidth)
     (set-line-width! instruction))
    ((hideTurtle)
     (delete-turtle!))
    ((showTurtle)
     (redraw-turtle! instruction))
    (else
     (error "unknown instruction:" (turtle-action-type instruction)))))

(define json-source-server "localhost:43334")
(define json-source-path "/api/PullBuffer")

(define (get-session-id!)
  (define session-source-path "/api/NewId")
  (define-values (status-code response-header new-id-json) (http-post json-source-server session-source-path "null"))
  (let ((p (open-input-string new-id-json)))
    (define new-id (json-read p))
    (close-input-port p)
    (set! page-id new-id)))

(define (on-interval!)
  (define-values (status-code response-header turtle-json) (http-post json-source-server json-source-path (number->string page-id)))
  (let ((p (open-input-string turtle-json)))
    (define turtle-json-raw (json-read p))
    (close-input-port p)
    (vector-for-each turtle-do! (vector-map json-object->turtle-action turtle-json-raw))))

(get-session-id!)
(tk-init '())
(tk-wm 'title "." "turtle")
(tk-grid (tk-canvas '.canvas '-width 600 '-height 600 '-bg 'black))

(set-bg-color! (json-object->turtle-action '((color . "black"))))
(set-line-color! (json-object->turtle-action '((color . "white"))))
(set-line-width! (json-object->turtle-action '((width . 1.0))))
(exit-handler (lambda (code fmtstr args) (tk-shutdown)))
(tk-bind "." '<Destroy> (tklambda () (exit)))

(define (background-loop)
  (on-interval!)
  (thread-sleep! 0.5)
  (background-loop))

(define t (make-thread background-loop))

(thread-start! t)

(tk-mainloop)
